perm filename PP.LSP[RUT,LSP] blob
sn#343762 filedate 1978-03-22 generic text, type T, neo UTF8
(DECLARE (SPECIAL PP PRETTYPROPS NOPRETTYPROPS PRETTYFLG COMMENTFLG COMMENTSTR
PPMAXLEN %%LL %%BR %%CC %%T %%LP %%RP LASTWORD EDITV INTERNSTR
)
(NOCALL %SPRINT %DEPTH %PPSIZE %PPSPEC %%LL %%BR %%CC %%T %%LP %%RP))
(DEFP ; NILL FSUBR)
(DEFP ;; NILL FSUBR)
(DRM /{ /{)
(DEFPROP /{
(LAMBDA NIL
(PROG (CH COM FLG INTERNSTR)
(SETQ COM (TCONC NIL 40.))
LOOP (COND [(OR [EQ (SETQ CH (TYI)) 32.] [AND [*LESS CH 14.] [*GREAT CH 8.]])
(SETQ FLG T)
(GO LOOP)]
[(NEQ CH 125.)
(COND [FLG (TCONC COM 32.) (SETQ FLG NIL)])
(TCONC COM (COND [(EQ CH 34.) 39.] [T CH]))
(GO LOOP)]
[(SETQ CH (MEMB 32. (CAR COM)))
(RPLACD CH (CONS 34. (CDR CH)))
(TCONC COM 34.)])
(TCONC COM 41.)
(RETURN (PROG1 (READLIST (CAR COM)) (FREELIST (CAR COM)) (FREE COM)))))
EXPR)
{;; (This comment has to follow the above definition). If your READLIST doesn't
allow ASCII values, the above readmacro and PP-COMMENT will have to be
modified.⎇
{;; Top level functions:⎇
(DEFPROP PPL
(LAMBDA (%L)
{;; Replaces GRINL. Outputs binding for function list unless already dumped
or atom was ALLFNS or ALLVALS.⎇
(PROG (LASTWORD EDITV) {; Don't change LASTWORD or EDITV⎇
(MAPC (FUNCTION
(LAMBDA (%A)
(COND [(AND [LITATOM %A] [SETQ %L (EVAL %A)])
(APPLY# 'PP %L)
(AND [NEQ %A 'ALLFNS]
[NEQ %A 'ALLVALS]
[NOT (MEMB %A %L)]
[APPLY# 'MBD: (LIST 'NOCOMPILE (LIST 'V: %A))])])))
%L)
(RETURN (IASCII 0.))))
FEXPR)
(DEFPROP PPL;
(LAMBDA (%L)
(PROG (COMMENTFLG) (SETQ COMMENTFLG T) (RETURN (APPLY# 'PPL %L))))
FEXPR)
(DEFPROP PP
(LAMBDA (%L)
{;; Replaces GRINDEF. Evaluates PPCOM commands - SPRINTs other lists (except
LAP code which is printed as such). Notifies user of any atoms with no
props on PRETTYPROPS.⎇
(PROG (%FLAG %D %CH)
(SETQ %CH (OUTCH))
(MAPC
(FUNCTION
(LAMBDA (%A)
(COND
[(CONSP %A)
(COND [(AND [CONSP (CAR %A)] [EQ (CAAR %A) 'LAP])
(TERPRI)
(PRIN1 (CAR %A))
(MAPC (FUNCTION
(LAMBDA (X)
(TAB (COND [(AND X [ATOM X]) 2.] [T 9.]))
(SETQ %A (PRIN1 X))))
(CDR %A))
(COND [%A (TAB 9.) (PRIN1 NIL)])
(TERPRI)]
[(AND [LITATOM (CAR %A)] [GET (CAR %A) 'PPCOM]) (EVAL %A)]
[T (TERPRI) (SPRINT %A 1.) (TERPRI)])]
[(LITATOM %A)
(COND [(GETL %A '(BROKEN-IN NAMESCHANGED))
(UNBREAK! %A)
(SETQ %L NIL)]
[T (SETQ %L (GET %A 'TRACE))])
(SETQ %FLAG NIL)
(MAPC
(FUNCTION
(LAMBDA (%P)
(PROG (%SP)
(COND [(CONSP %P) (SETQ %SP (CDR %P)) (SETQ %P (CAR %P))])
(COND
[(MEMB %P '(EXPR FEXPR MACRO))
(COND
[(AND [SETQ %D (GET %A %P)]
[OR [NULL %L]
[SETQ %D
(GET (CDR %L)
(COND [(EQ %P 'MACRO) 'FEXPR]
[T %P]))]])
(AND [NULL %CH] [SETQ LASTWORD %A])]
[T (RETURN NIL)])]
[(EQ %P 'VALUE)
(COND [(AND [SETQ %D (GET %A %P)]
[NEQ (CDR %D) (UNBOUND)])
(AND [NULL %CH] [SETQ EDITV %A])
(UNMACEXPAND (CDR %D))
(GO SKIP)]
[T (RETURN NIL)])]
[(NULL (SETQ %D (GET %A %P))) (RETURN NIL)])
(UNMACEXPAND %D) {; Get rid of any macro expansions⎇
SKIP (SETQ %FLAG T)
(TERPRI)
(COND [%SP (%SP %A %D %P)]
[T (SPRINT (LIST 'DEFPROP %A %D %P) 1.)])
(TERPRI))))
PRETTYPROPS)
(COND [(AND PP %CH %FLAG)
(OUTC NIL NIL)
(MSG %A 1.)
(OUTC %CH NIL)]
[(AND [NULL %FLAG] NOPRETTYPROPS)
(TTYMSG -1. %A " has no properties on PRETTYPROPS." T)])]
[T (MSG T %A T)])))
(OR %L [LIST LASTWORD]))
(RETURN (IASCII 0.))))
FEXPR)
(DEFV PP NIL)
(DEFV NOPRETTYPROPS T)
(DEFPROP PP;
(LAMBDA (%L)
(PROG (COMMENTFLG) (SETQ COMMENTFLG T) (RETURN (APPLY# 'PP %L))))
FEXPR)
{;; PPCOM command functions:⎇
(DEFPROP *PG* (LAMBDA NIL (TYO 12.) NIL) EXPR)
(DEFPROP F:
(LAMBDA (L)
(PROG (PRETTYPROPS)
(SETQ PRETTYPROPS '(EXPR FEXPR MACRO))
(RETURN (AND L [APPLY# 'PP L]))))
FEXPR)
(DEFPROP P:
(LAMBDA (L)
(PROG (PRETTYPROPS)
(SETQ PRETTYPROPS (CAR L))
(RETURN (AND [CDR L] [APPLY# 'PP (CDR L)]))))
FEXPR)
(DEFPROP V:
(LAMBDA (L)
(MAPC (FUNCTION
(LAMBDA (X)
(PROG (V)
(COND [(LITATOM X)
(SETQ V (GET X 'VALUE))
(AND [EQ (CDR V) (UNBOUND)] [SETQ V '(NIL)])]
[(AND [CONSP X] [LITATOM (CAR X)])
(SETQ V (CONS NIL (CADR X)))
(SETQ X (CAR X))]
[T (RETURN (MSG T X T))])
(UNMACEXPAND (CDR V)) {; Just in case the value of this
variable is ever EVALed⎇
(TERPRI)
(PP-VALUE X V 'VALUE)
(TERPRI)
(AND PP [OUTCH] [TTYOUT (MSG X 1.)]))))
L)
(IASCII 0.))
FEXPR)
(DEFPROP MBD:
(LAMBDA (L)
(COND [(CDR L)
(MSG T "(" (CAR L))
(APPLY# 'PP (CDR L))
(MSG ")" T)
(IASCII 0.)]))
FEXPR)
(DEFPROP FORMS:
(LAMBDA (L)
(MAPC (FUNCTION (LAMBDA (X) (TERPRI) (SPRINT X 1.) (TERPRI))) L)
(IASCII 0.))
FEXPR)
(DEFP E: PROGN FSUBR)
(DEFLIST (*PG* F: P: V: MBD: FORMS: E:) T PPCOM)
{;; SPRINT and friends:⎇
(DEFPROP SPRINT
(LAMBDA (%E %C)
{;; SPRINT now does a quick dump if PRETTYFLG=NIL⎇
(SETQ %%LL (LINELENGTH NIL)) {; Just retrieve this once!⎇
(TAB (OR %C 1.))
(COND [(OR [NULL PRETTYFLG] [PATOM %E]) (PRIN1 %E)]
[T (%SPRINT %E NIL)])
NIL)
EXPR)
(DEFPROP %SPRINT
(LAMBDA (%E %BR)
{;; Prettyprints the (non-atomic) structure %E using parentheses if %BR=NIL
and brackets if %BR=T. Checks for printmacros and lists of atoms (printed
as blocks).⎇
(PROG (%C %CE)
(COND [%BR (SETQ %%LP 91.) (SETQ %BR (SETQ %%RP 93.))]
[T (SETQ %%LP 40.) (SETQ %BR (SETQ %%RP 41.))])
START (SETQ %C (ADD1 (CHRPOS)))
(COND [(CONSP (SETQ %CE (CAR %E)))
(TYO %%LP)
(%SPRINT %CE NIL)
(SETQ %%BR NIL)
(GO REST)]
[(AND [LITATOM %CE] [SETQ %%T (GET %CE 'PRINTMACRO)])
(COND [(STRINGP %%T)
(AND [OR [PATOM (CDR %E)] [CDDR %E]] [GO OK])
(PRINC %%T)
(COND [(PATOM (SETQ %E (CADR %E))) (RETURN (PRIN1 %E))]
[T (GO START)])]
[(EQ %%T 'BRACKETS) (SETQ %%BR T) (GO OK1)]
[(NEQ (%%T %E) 'SPRINT) (RETURN NIL)])])
OK (SETQ %%BR NIL)
OK1 (TYO %%LP)
(PRIN1 %CE)
REST (COND [(PATOM (SETQ %E (CDR %E))) (PP-LSEG %E %C %C %%BR)]
[(MINUSP (%PPSIZE %CE (*MIN (*DIF %%LL %C) 50.) T))
(PP-LSEG %E %C %C %%BR)]
[(NOT (MINUSP (%PPSIZE %E (*MIN (SETQ %%CC (CHRCT)) PPMAXLEN) NIL)
))
(PP-LSEG %E NIL NIL %%BR)]
[(AND [PATOM %CE]
[PROG (%E1)
(SETQ %E1 %E)
A (COND [(CONSP (CAR %E1)) (RETURN NIL)]
[(PATOM (SETQ %E1 (CDR %E1))) (RETURN T)]
[T (GO A)])])
(PP-LSEG %E NIL (ADD1 (CHRPOS)) %%BR)]
[(OR [*GREAT (SETQ %%T (*DIF (CHRPOS) %C)) 12.]
[CONSP %CE]
[AND [*GREAT %%T 1.] [*GREAT (*TIMES 6. (%DEPTH %E)) %%CC]])
(PP-LSEG %E %C %C %%BR)]
[T (TYO 32.) (PP-LSEG %E (SETQ %CE (CHRPOS)) %CE %%BR)])
(TYOA %BR %C)))
EXPR)
(DEFV PPMAXLEN 65.)
(DEFPROP %DEPTH
(LAMBDA (%S)
{;; Returns the maximum nesting depth of the list structure %S⎇
(PROG (%N)
(SETQ %N 1.)
LOOP (AND [CONSP (CAR %S)] [SETQ %N (*MAX %N (ADD1 (%DEPTH (CAR %S))))])
(COND [(CONSP (SETQ %S (CDR %S))) (GO LOOP)] [T (RETURN %N)])))
EXPR)
(DEFPROP %PPSIZE
(LAMBDA (%E %N %F)
{;; Checks to see if %E can be SPRINTed in %N spaces. Returns negative number
if it can't, and number of spaces left over if it can. %F is T if %E is a
real expression (a check is then made for a printmacro string). If %F is
NIL %E is a segment (no top-level check for printmacro).⎇
(PROG NIL
START (COND [(PATOM %E) (RETURN (*DIF %N (FLATSIZE %E)))]
[(AND %F [LITATOM (CAR %E)] [SETQ %F (GET (CAR %E) 'PRINTMACRO)])
(COND [(AND [STRINGP %F] [CONSP (CDR %E)] [NULL (CDDR %E)])
(SETQ %N (*DIF %N (FLATSIZEC %F)))
(SETQ %E (CADR %E))
(GO START)]
[(SETQ %F (GET (CAR %E) 'COMMENT))
(AND [NULL (OUTCH)]
[NULL COMMENTFLG]
[RETURN (*DIF %N 9.)])
(AND [NUMBERP %F] [RETURN -1.])])])
(SETQ %N (SUB1 (*DIF %N (LENGTH %E))))
LOOP (COND [(MINUSP %N) (RETURN %N)] [T (SETQ %N (%PPSIZE (CAR %E) %N T))])
(COND [(CONSP (SETQ %E (CDR %E))) (GO LOOP)]
[(NULL %E) (RETURN %N)]
[T (RETURN (DIFFERENCE %N (FLATSIZE %E) 3.))])))
EXPR)
(DEFPROP PP-LSEG
(LAMBDA (%L %C1 %C2 %BR)
{;; Prints the list-segment %L. %C1 gives column to print lists in. %C2
gives column to print atoms in (if %C2 is NIL atoms are automatically
outdented). If %C1 is NIL the elements are printed as a block (%C2 then
gives the column to resume printing if an element won't fit on the line).
%BR is the bracket flag to pass to %SPRINT.⎇
(PROG NIL
LOOP (AND [PATOM %L] [GO DONE])
LOOP1 (COND [(NULL %C1)
(COND [(AND %C2 [MINUSP (%PPSIZE (CAR %L) (SUB1 (CHRCT)) T)])
(TAB %C2)]
[T (TYO 32.)])
(COND [(PATOM (CAR %L)) (PRIN1 (CAR %L)) (GO NEXT)])]
[(PATOM (CAR %L))
(TAB (OR %C2 [*MAX 2. (SUB1 (*DIF %C1 (FLATSIZE (CAR %L))))]))
(PRIN1 (CAR %L))
(COND [(CONSP (SETQ %L (CDR %L))) (TYO 32.) (GO LOOP1)])
(GO DONE)]
[(AND [LITATOM (CAAR %L)] [NUMBERP (GET (CAAR %L) 'COMMENT)])
(TYO 32.)]
[T (TAB %C1)])
(%SPRINT (CAR %L) %BR)
NEXT (SETQ %L (CDR %L))
(GO LOOP)
DONE (COND [%L (AND [*LESS (CHRCT) (*PLUS (FLATSIZE %L) 3.)]
[TAB (OR %C1 %C2)])
(PRINC " . ")
(PRIN1 %L)])))
EXPR)
{;; Special formatting routines:⎇
(DEFPROP PP-FORMAT
(LAMBDA (%L %N %F)
{;; Formats the list %L with the first %N+1 elements (the function name and %N
arguments) printed as a block. %F specifies how the rest of the list (the
body) will be printed: if %F=NIL (standard format) all elements will be
printed under the first argument; if %F=LABELS all non-atomic expressions
will be printed under the first argument with atoms placed to the left (as
labels); if %F=MISER all elements will be printed under the function
name.⎇
(PROG (%C1 %C2 %RP)
(SETQ %RP %%RP)
(TYO %%LP)
(SETQ %C1 (CHRPOS))
(PRIN1 (CAR %L))
(SETQ %C2 (ADD1 (CHRPOS)))
(COND [(NOT (MINUSP (%PPSIZE (SETQ %L (CDR %L))
(*MIN (CHRCT) PPMAXLEN)
NIL)))
(PP-LSEG %L NIL NIL NIL)]
[T (COND [(*GREAT %N 0.)
(PP-LSEG (SETQ %N
(LDIFF %L (SETQ %L (NTH (CDR %L) %N))))
NIL
%C2
NIL)]
[T (SETQ %N NIL)])
(PP-LSEG %L
(COND [(EQ %F 'MISER) %C1] [T %C2])
(COND [(NULL %F) %C2] [(EQ %F 'MISER) %C1])
NIL)
(AND %L [FREELIST %N])])
(TYOA %RP %C1)))
EXPR)
(DEFPROP PP-VALUE
(LAMBDA (%A %D %P)
{;; Special formatter for VALUE props⎇
(AND %A
[NEQ %A T]
[PRINA (LIST 'DEFV %A (CDR %D)) (PLUS (CHRPOS) (FLATSIZE %A) 8.)]))
EXPR)
(DEFPROP PP-RMACS
(LAMBDA (%A %D %P)
{;; Special formatter for READMACRO props⎇
(SETQ %P (SETCHR %A NIL))
(SPRINT (LIST (COND [(EQ %P 11.) 'DSM] [T 'DRM]) %A %D) 1.))
EXPR)
(DEFPROP PP-COMMENT
(LAMBDA (%L)
{;; This is the comment printer. Note that it will have to be fixed if
AEXPLODEC is not present.⎇
(PROG (COL WORD LSAVE)
(AND [NULL (OUTCH)] [NULL COMMENTFLG] [RETURN (PRINC "*COMMENT*")])
(AND [NUMBERP (SETQ COL (GET (CAR %L) 'COMMENT))] [TAB COL])
(COND [(CDR (LAST %L)) (RETURN (PRINA %L (CHRPOS)))])
(TYO (COND [COMMENTSTR 123.] [T 40.]))
(PRIN1 (CAR %L))
(SETQ COL (ADD1 (CHRPOS)))
(COND [(OR [NOT (STRINGP (CADR %L))] [CDDR %L])
(TYO 32.)
(COND [COMMENTSTR (PRINLC (CDR %L) COL)]
[T (PRINL (CDR %L) COL)])
(GO DONE)])
(SETQ %L (SETQ LSAVE (NCONC (AEXPLODEC (CADR %L)) (LIST 0.))))
LOOP (SETQ WORD (MEMB 32. %L))
(SETQ %L (PROG1 (CDR WORD) (SETQ WORD (LDIFF %L WORD))))
(COND [(NOT (*LESS (LENGTH WORD) (CHRCT))) (TAB COL)] [T (TYO 32.)])
(MAPC (FUNCTION
(LAMBDA (CH)
(AND [NULL COMMENTSTR] [DELIM CH] [TYO 47.])
(TYO CH)))
WORD)
(AND [EQ (CAR (LAST WORD)) 46.] [NEQ (CHRCT) 0.] [TYO 32.])
(COND [%L (FREELIST WORD) (GO LOOP)] [T (FREELIST LSAVE)])
DONE (TYOA (COND [COMMENTSTR 125.] [T 41.]) COL)))
EXPR)
(DEFPROP PP-MISER
(LAMBDA (%L) (PP-FORMAT %L (OR [GET (CAR %L) 'PP-MISER] 1.) 'MISER))
EXPR)
(DEFPROP PP-LABELS
(LAMBDA (%L) (PP-FORMAT %L (OR [GET (CAR %L) 'PP-LABELS] 1.) 'LABELS))
EXPR)
(DEFPROP PP-SPECIAL
(LAMBDA (%L) (%PPSPEC %L (OR [GET (CAR %L) 'PP-SPECIAL] 1.)))
EXPR)
(DEFPROP PP-DO
(LAMBDA (%L)
(%PPSPEC %L
(COND [(ATOM (CDR %L)) 0.]
[T (SELECTQ [CADR %L] [(WHILE UNTIL) 2.] [FOR 4.] 0.)])))
EXPR)
(DEFPROP %PPSPEC
(LAMBDA (%L %N)
(PP-FORMAT %L
%N
(AND [*GREAT (*TIMES 6. (%DEPTH %L))
(*DIF (CHRCT) (FLATSIZE (CAR %L)))]
'MISER)))
EXPR)
(DEFLIST (DEFPROP LAMBDA FUNCTION *FUNCTION) PP-MISER PRINTMACRO)
(DEFLIST (FUNCTION *FUNCTION) 0. PP-MISER)
(DEFLIST (PROG) PP-LABELS PRINTMACRO)
(DEFLIST (DEFP DEFV SETQ DRM DSM DE DF DM DV F:L RPTQ PUSH)
PP-SPECIAL
PRINTMACRO)
(DEFLIST (DE DF DM) 2. PP-SPECIAL)
(DEFPROP DO PP-DO PRINTMACRO)
(DEFLIST (COND AND OR SELECTQ CATCH) BRACKETS PRINTMACRO)
(DEFPROP QUOTE "'" PRINTMACRO)
(DEFPROP ; PP-COMMENT PRINTMACRO)
(DEFPROP ;; PP-COMMENT PRINTMACRO)
(DEFPROP ; 40. COMMENT)
(DEFPROP ;; T COMMENT)
(DEFV PRETTYFLG T)
(DEFV COMMENTFLG NIL)
(DEFV COMMENTSTR T)
(DEFV PRETTYPROPS (SPECIAL (READMACRO . PP-RMACS) EXPR FEXPR MACRO
(VALUE . PP-VALUE) PRINTMACRO))
{;; In case someone gets cute and calls %SPRINT or PP-FORMAT directly instead of
going thru SPRINT:⎇
(PROGN (SETQ %%LL (LINELENGTH NIL)) (SETQ %%LP 40.) (SETQ %%RP 41.))
{;; Set up names for GRINers:⎇
(PROGN (DEFP GRINDEF PP (FEXPR FSUBR))
(DEFP GRINL PPL (FEXPR FSUBR))
(REMPROP 'GRINPROPS 'VALUE)
(DEFP GRINPROPS PRETTYPROPS VALUE))
(NOCOMPILE
(DEFV PPFNS ((DECLARE (SPECIAL PP PRETTYPROPS NOPRETTYPROPS PRETTYFLG
COMMENTFLG COMMENTSTR PPMAXLEN %%LL %%BR %%CC %%T %%LP %%RP
LASTWORD EDITV INTERNSTR) (NOCALL %SPRINT %DEPTH %PPSIZE %PPSPEC
%%LL %%BR %%CC %%T %%LP %%RP)) (DEFP ; NILL FSUBR) (DEFP ;; NILL
FSUBR) /{ (;;
"(This comment has to follow the above definition). If your READLIS→
T doesn't allow ASCII values, the above readmacro and PP-COMMENT will have to be→
modified.") (;; "Top level functions:") (F: PPL PPL; PP (V: (PP NIL)
(NOPRETTYPROPS T)) PP;) (;; "PPCOM command functions:")
(F: *PG* F: P: V: MBD: FORMS: (DEFP E: PROGN FSUBR) (DEFLIST
(*PG* F: P: V: MBD: FORMS: E:) T PPCOM)) (;;
"SPRINT and friends:") (F: SPRINT %SPRINT (V: PPMAXLEN) %DEPTH
%PPSIZE PP-LSEG) (;; "Special formatting routines:") (F:
PP-FORMAT PP-VALUE PP-RMACS PP-COMMENT PP-MISER PP-LABELS
PP-SPECIAL PP-DO %PPSPEC) (DEFLIST (DEFPROP LAMBDA FUNCTION
*FUNCTION) PP-MISER PRINTMACRO) (DEFLIST (FUNCTION *FUNCTION) 0.
PP-MISER) (DEFLIST (PROG) PP-LABELS PRINTMACRO) (DEFLIST
(DEFP DEFV SETQ DRM DSM DE DF DM DV F:L RPTQ PUSH) PP-SPECIAL
PRINTMACRO) (DEFLIST (DE DF DM) 2. PP-SPECIAL) (P: (PRINTMACRO)
DO) (DEFLIST (COND AND OR SELECTQ CATCH) BRACKETS PRINTMACRO)
(P: (PRINTMACRO) QUOTE ; ;;) (P: (COMMENT) ; ;;) (V: (PRETTYFLG
T) (COMMENTFLG NIL) COMMENTSTR PRETTYPROPS) (;;
"In case someone gets cute and calls %SPRINT or PP-FORMAT directly →
instead of going thru SPRINT:") (PROGN (SETQ %%LL (LINELENGTH NIL))
(SETQ %%LP 40.) (SETQ %%RP 41.)) (;; "Set up names for GRINers:")
(PROGN (DEFP GRINDEF PP (FEXPR FSUBR)) (DEFP GRINL PPL
(FEXPR FSUBR)) (REMPROP (QUOTE GRINPROPS) (QUOTE VALUE))
(DEFP GRINPROPS PRETTYPROPS VALUE))))
)